!--------------------------------------------------------------------------------------------------!
!   CP2K: A general program to perform molecular dynamics simulations                              !
!   Copyright 2000-2025 CP2K developers group <https://cp2k.org>                                   !
!                                                                                                  !
!   SPDX-License-Identifier: GPL-2.0-or-later                                                      !
!--------------------------------------------------------------------------------------------------!

! **************************************************************************************************
!> \brief Calculation of overlap matrix, its derivatives and forces
!> \par History
!>      JGH: removed printing routines
!>      JGH: upgraded to unique routine for overlaps
!>      JGH: Add specific routine for 'forces only'
!>           Major refactoring for new overlap routines
!>      JGH: Kpoints
!>      JGH: openMP refactoring
!> \author Matthias Krack (03.09.2001,25.06.2003)
! **************************************************************************************************
MODULE qs_overlap
   USE ai_contraction,                  ONLY: block_add,&
                                              contraction,&
                                              decontraction,&
                                              force_trace
   USE ai_overlap,                      ONLY: overlap_ab
   USE atomic_kind_types,               ONLY: atomic_kind_type,&
                                              get_atomic_kind_set
   USE basis_set_types,                 ONLY: get_gto_basis_set,&
                                              gto_basis_set_p_type,&
                                              gto_basis_set_type
   USE block_p_types,                   ONLY: block_p_type
   USE cp_control_types,                ONLY: dft_control_type
   USE cp_dbcsr_api,                    ONLY: &
        dbcsr_create, dbcsr_distribution_type, dbcsr_filter, dbcsr_finalize, dbcsr_get_block_p, &
        dbcsr_p_type, dbcsr_type, dbcsr_type_antisymmetric, dbcsr_type_no_symmetry, &
        dbcsr_type_symmetric
   USE cp_dbcsr_cp2k_link,              ONLY: cp_dbcsr_alloc_block_from_nbl
   USE cp_dbcsr_operations,             ONLY: dbcsr_allocate_matrix_set
   USE kinds,                           ONLY: default_string_length,&
                                              dp,&
                                              int_8
   USE kpoint_types,                    ONLY: get_kpoint_info,&
                                              kpoint_type
   USE orbital_pointers,                ONLY: indco,&
                                              ncoset
   USE orbital_symbols,                 ONLY: cgf_symbol
   USE particle_methods,                ONLY: get_particle_set
   USE particle_types,                  ONLY: particle_type
   USE qs_force_types,                  ONLY: qs_force_type
   USE qs_integral_utils,               ONLY: basis_set_list_setup,&
                                              get_memory_usage
   USE qs_kind_types,                   ONLY: qs_kind_type
   USE qs_ks_types,                     ONLY: get_ks_env,&
                                              qs_ks_env_type
   USE qs_neighbor_list_types,          ONLY: get_neighbor_list_set_p,&
                                              neighbor_list_set_p_type
   USE string_utilities,                ONLY: compress,&
                                              uppercase
   USE virial_methods,                  ONLY: virial_pair_force
   USE virial_types,                    ONLY: virial_type

!$ USE OMP_LIB, ONLY: omp_lock_kind, &
!$                    omp_init_lock, omp_set_lock, &
!$                    omp_unset_lock, omp_destroy_lock

#include "./base/base_uses.f90"

   IMPLICIT NONE

   PRIVATE

! *** Global parameters ***

   CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'qs_overlap'

   ! should be a parameter, but this triggers a bug in OMPed code with gfortran 4.9
   INTEGER, DIMENSION(1:56), SAVE :: ndod = [0, 1, 1, 1, 0, 0, 0, 0, 0, 0, 1, 1, 1, &
                                             1, 1, 1, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, &
                                             0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 1, 1, &
                                             1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1]

   INTERFACE create_sab_matrix
      MODULE PROCEDURE create_sab_matrix_1d, create_sab_matrix_2d
   END INTERFACE

! *** Public subroutines ***

   PUBLIC :: build_overlap_matrix, build_overlap_matrix_simple, &
             build_overlap_force, create_sab_matrix

CONTAINS

! **************************************************************************************************
!> \brief   Calculation of the overlap matrix over Cartesian Gaussian functions.
!> \param   ks_env the QS env
!> \param   matrix_s The overlap matrix to be calculated (optional)
!> \param   matrixkp_s The overlap matrices to be calculated (kpoints, optional)
!> \param   matrix_name The name of the overlap matrix (i.e. for output)
!> \param   nderivative Derivative with respect to basis origin
!> \param   basis_type_a basis set to be used for bra in <a|b>
!> \param   basis_type_b basis set to be used for ket in <a|b>
!> \param   sab_nl pair list (must be consistent with basis sets!)
!> \param   calculate_forces (optional) ...
!> \param   matrix_p density matrix for force calculation (optional)
!> \param   matrixkp_p density matrix for force calculation with k_points (optional)
!> \date    11.03.2002
!> \par     History
!>          Enlarged functionality of this routine. Now overlap matrices based
!>          on different basis sets can be calculated, taking into account also
!>          mixed overlaps NOTE: the pointer to the overlap matrix must now be
!>          put into its corresponding env outside of this routine
!>          [Manuel Guidon]
!>          Generalized for derivatives and force calculations [JHU]
!>          Kpoints, returns overlap matrices in real space index form
!> \author  MK
!> \version 1.0
! **************************************************************************************************
   SUBROUTINE build_overlap_matrix(ks_env, matrix_s, matrixkp_s, matrix_name, &
                                   nderivative, basis_type_a, basis_type_b, sab_nl, calculate_forces, &
                                   matrix_p, matrixkp_p)

      TYPE(qs_ks_env_type), POINTER                      :: ks_env
      TYPE(dbcsr_p_type), DIMENSION(:), OPTIONAL, &
         POINTER                                         :: matrix_s
      TYPE(dbcsr_p_type), DIMENSION(:, :), OPTIONAL, &
         POINTER                                         :: matrixkp_s
      CHARACTER(LEN=*), INTENT(IN), OPTIONAL             :: matrix_name
      INTEGER, INTENT(IN), OPTIONAL                      :: nderivative
      CHARACTER(LEN=*), INTENT(IN)                       :: basis_type_a, basis_type_b
      TYPE(neighbor_list_set_p_type), DIMENSION(:), &
         POINTER                                         :: sab_nl
      LOGICAL, INTENT(IN), OPTIONAL                      :: calculate_forces
      TYPE(dbcsr_type), OPTIONAL, POINTER                :: matrix_p
      TYPE(dbcsr_p_type), DIMENSION(:, :), OPTIONAL, &
         POINTER                                         :: matrixkp_p

      INTEGER                                            :: natom

      MARK_USED(int_8)

      CALL get_ks_env(ks_env, natom=natom)

      CALL build_overlap_matrix_low(ks_env, matrix_s, matrixkp_s, matrix_name, nderivative, &
                                    basis_type_a, basis_type_b, sab_nl, calculate_forces, &
                                    matrix_p, matrixkp_p, natom)

   END SUBROUTINE build_overlap_matrix

! **************************************************************************************************
!> \brief Implementation of build_overlap_matrix with the additional natom argument passed in to
!>        allow for explicitly shaped force_thread array which is needed for OMP REDUCTION.
!> \param ks_env ...
!> \param matrix_s ...
!> \param matrixkp_s ...
!> \param matrix_name ...
!> \param nderivative ...
!> \param basis_type_a ...
!> \param basis_type_b ...
!> \param sab_nl ...
!> \param calculate_forces ...
!> \param matrix_p ...
!> \param matrixkp_p ...
!> \param natom ...
! **************************************************************************************************
   SUBROUTINE build_overlap_matrix_low(ks_env, matrix_s, matrixkp_s, matrix_name, nderivative, &
                                       basis_type_a, basis_type_b, sab_nl, calculate_forces, &
                                       matrix_p, matrixkp_p, natom)

      TYPE(qs_ks_env_type), POINTER                      :: ks_env
      TYPE(dbcsr_p_type), DIMENSION(:), OPTIONAL, &
         POINTER                                         :: matrix_s
      TYPE(dbcsr_p_type), DIMENSION(:, :), OPTIONAL, &
         POINTER                                         :: matrixkp_s
      CHARACTER(LEN=*), INTENT(IN), OPTIONAL             :: matrix_name
      INTEGER, INTENT(IN), OPTIONAL                      :: nderivative
      CHARACTER(LEN=*), INTENT(IN)                       :: basis_type_a, basis_type_b
      TYPE(neighbor_list_set_p_type), DIMENSION(:), &
         POINTER                                         :: sab_nl
      LOGICAL, INTENT(IN), OPTIONAL                      :: calculate_forces
      TYPE(dbcsr_type), OPTIONAL, POINTER                :: matrix_p
      TYPE(dbcsr_p_type), DIMENSION(:, :), OPTIONAL, &
         POINTER                                         :: matrixkp_p
      INTEGER, INTENT(IN)                                :: natom

      CHARACTER(len=*), PARAMETER :: routineN = 'build_overlap_matrix_low'

      INTEGER :: atom_a, handle, i, iatom, ic, icol, ikind, irow, iset, jatom, jkind, jset, ldsab, &
         maxder, maxs, n1, n2, ncoa, ncob, nder, nimg, nkind, nseta, nsetb, sgfa, sgfb, slot
      INTEGER, ALLOCATABLE, DIMENSION(:)                 :: atom_of_kind, kind_of
      INTEGER, DIMENSION(3)                              :: cell
      INTEGER, DIMENSION(:), POINTER                     :: la_max, la_min, lb_max, lb_min, npgfa, &
                                                            npgfb, nsgfa, nsgfb
      INTEGER, DIMENSION(:, :), POINTER                  :: first_sgfa, first_sgfb
      INTEGER, DIMENSION(:, :, :), POINTER               :: cell_to_index
      LOGICAL                                            :: do_forces, do_symmetric, dokp, found, &
                                                            trans, use_cell_mapping, use_virial
      REAL(KIND=dp)                                      :: dab, f, f0, ff, rab2
      REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :)        :: owork, pmat
      REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :)     :: oint
      REAL(KIND=dp), DIMENSION(3)                        :: force_a, rab
      REAL(KIND=dp), DIMENSION(3, 3)                     :: pv_thread
      REAL(KIND=dp), DIMENSION(3, natom)                 :: force_thread
      REAL(KIND=dp), DIMENSION(:), POINTER               :: set_radius_a, set_radius_b
      REAL(KIND=dp), DIMENSION(:, :), POINTER            :: p_block, rpgfa, rpgfb, scon_a, scon_b, &
                                                            zeta, zetb
      TYPE(atomic_kind_type), DIMENSION(:), POINTER      :: atomic_kind_set
      TYPE(block_p_type), ALLOCATABLE, DIMENSION(:)      :: sint
      TYPE(dft_control_type), POINTER                    :: dft_control
      TYPE(gto_basis_set_p_type), DIMENSION(:), POINTER  :: basis_set_list_a, basis_set_list_b
      TYPE(gto_basis_set_type), POINTER                  :: basis_set_a, basis_set_b
      TYPE(kpoint_type), POINTER                         :: kpoints
      TYPE(qs_force_type), DIMENSION(:), POINTER         :: force
      TYPE(qs_kind_type), DIMENSION(:), POINTER          :: qs_kind_set
      TYPE(virial_type), POINTER                         :: virial

!$    INTEGER(kind=omp_lock_kind), &
!$       ALLOCATABLE, DIMENSION(:) :: locks
!$    INTEGER                                            :: lock_num, hash, hash1, hash2
!$    INTEGER(KIND=int_8)                                :: iatom8
!$    INTEGER, PARAMETER                                 :: nlock = 501

      CALL timeset(routineN, handle)

      ! test for matrices (kpoints or standard gamma point)
      IF (PRESENT(matrix_s)) THEN
         dokp = .FALSE.
         use_cell_mapping = .FALSE.
      ELSEIF (PRESENT(matrixkp_s)) THEN
         dokp = .TRUE.
         CALL get_ks_env(ks_env=ks_env, kpoints=kpoints)
         CALL get_kpoint_info(kpoint=kpoints, cell_to_index=cell_to_index)
         use_cell_mapping = (SIZE(cell_to_index) > 1)
      ELSE
         CPABORT("")
      END IF

      NULLIFY (atomic_kind_set)
      CALL get_ks_env(ks_env, &
                      atomic_kind_set=atomic_kind_set, &
                      qs_kind_set=qs_kind_set, &
                      dft_control=dft_control)

      nimg = dft_control%nimages
      nkind = SIZE(qs_kind_set)

      IF (PRESENT(calculate_forces)) THEN
         do_forces = calculate_forces
      ELSE
         do_forces = .FALSE.
      END IF

      IF (PRESENT(nderivative)) THEN
         nder = nderivative
      ELSE
         nder = 0
      END IF
      maxder = ncoset(nder)

      ! check for symmetry
      CPASSERT(SIZE(sab_nl) > 0)
      CALL get_neighbor_list_set_p(neighbor_list_sets=sab_nl, symmetric=do_symmetric)
      IF (do_symmetric) THEN
         CPASSERT(basis_type_a == basis_type_b)
      END IF

      ! set up basis set lists
      ALLOCATE (basis_set_list_a(nkind), basis_set_list_b(nkind))
      CALL basis_set_list_setup(basis_set_list_a, basis_type_a, qs_kind_set)
      CALL basis_set_list_setup(basis_set_list_b, basis_type_b, qs_kind_set)

      IF (dokp) THEN
         CALL dbcsr_allocate_matrix_set(matrixkp_s, maxder, nimg)
         CALL create_sab_matrix(ks_env, matrixkp_s, matrix_name, basis_set_list_a, basis_set_list_b, &
                                sab_nl, do_symmetric)
      ELSE
         CALL dbcsr_allocate_matrix_set(matrix_s, maxder)
         CALL create_sab_matrix(ks_env, matrix_s, matrix_name, basis_set_list_a, basis_set_list_b, &
                                sab_nl, do_symmetric)
      END IF
      maxs = maxder

      use_virial = .FALSE.
      IF (do_forces) THEN
         CALL get_ks_env(ks_env=ks_env, force=force, virial=virial)
         use_virial = virial%pv_availability .AND. (.NOT. virial%pv_numer)
      END IF

      force_thread = 0.0_dp
      pv_thread = 0.0_dp

      ldsab = get_memory_usage(qs_kind_set, basis_type_a, basis_type_b)
      IF (do_forces) THEN
         ! we need density matrix for forces
         IF (dokp) THEN
            CPASSERT(PRESENT(matrixkp_p))
         ELSE
            CPASSERT(PRESENT(matrix_p))
         END IF
         nder = MAX(nder, 1)
      END IF
      maxder = ncoset(nder)

!$OMP PARALLEL DEFAULT(NONE) &
!$OMP SHARED (do_forces, ldsab, maxder, use_cell_mapping, do_symmetric, maxs, dokp, &
!$OMP         ncoset, nder, use_virial, ndod, sab_nl, nimg,&
!$OMP         matrix_s, matrix_p,basis_set_list_a, basis_set_list_b, cell_to_index, &
!$OMP         matrixkp_s, matrixkp_p, locks, natom)  &
!$OMP PRIVATE (oint, owork, pmat, sint, ikind, jkind, iatom, jatom, rab, cell, &
!$OMP          basis_set_a, basis_set_b, lock_num, &
!$OMP          first_sgfa, la_max, la_min, npgfa, nsgfa, nseta, rpgfa, set_radius_a, ncoa, ncob, force_a, &
!$OMP          zeta, first_sgfb, lb_max, lb_min, npgfb, nsetb, rpgfb, set_radius_b, nsgfb, p_block, dab, f,  &
!$OMP          zetb, scon_a, scon_b, ic, irow, icol, f0, ff, found, trans, rab2, n1, n2, sgfa, sgfb, iset, jset, &
!$OMP          hash, hash1, hash2, iatom8, slot ) &
!$OMP REDUCTION (+ : pv_thread, force_thread )

!$OMP SINGLE
!$    ALLOCATE (locks(nlock))
!$OMP END SINGLE

!$OMP DO
!$    DO lock_num = 1, nlock
!$       call omp_init_lock(locks(lock_num))
!$    END DO
!$OMP END DO

      NULLIFY (p_block)
      ALLOCATE (oint(ldsab, ldsab, maxder), owork(ldsab, ldsab))
      IF (do_forces) ALLOCATE (pmat(ldsab, ldsab))
      ALLOCATE (sint(maxs))
      DO i = 1, maxs
         NULLIFY (sint(i)%block)
      END DO

!$OMP DO SCHEDULE(GUIDED)
      DO slot = 1, sab_nl(1)%nl_size

         ikind = sab_nl(1)%nlist_task(slot)%ikind
         jkind = sab_nl(1)%nlist_task(slot)%jkind
         iatom = sab_nl(1)%nlist_task(slot)%iatom
         jatom = sab_nl(1)%nlist_task(slot)%jatom
         cell(:) = sab_nl(1)%nlist_task(slot)%cell(:)
         rab(1:3) = sab_nl(1)%nlist_task(slot)%r(1:3)

         basis_set_a => basis_set_list_a(ikind)%gto_basis_set
         IF (.NOT. ASSOCIATED(basis_set_a)) CYCLE
         basis_set_b => basis_set_list_b(jkind)%gto_basis_set
         IF (.NOT. ASSOCIATED(basis_set_b)) CYCLE

!$       iatom8 = INT(iatom - 1, int_8)*INT(natom, int_8) + INT(jatom, int_8)
!$       hash1 = INT(MOD(iatom8, INT(nlock, int_8)) + 1)

         ! basis ikind
         first_sgfa => basis_set_a%first_sgf
         la_max => basis_set_a%lmax
         la_min => basis_set_a%lmin
         npgfa => basis_set_a%npgf
         nseta = basis_set_a%nset
         nsgfa => basis_set_a%nsgf_set
         rpgfa => basis_set_a%pgf_radius
         set_radius_a => basis_set_a%set_radius
         scon_a => basis_set_a%scon
         zeta => basis_set_a%zet
         ! basis jkind
         first_sgfb => basis_set_b%first_sgf
         lb_max => basis_set_b%lmax
         lb_min => basis_set_b%lmin
         npgfb => basis_set_b%npgf
         nsetb = basis_set_b%nset
         nsgfb => basis_set_b%nsgf_set
         rpgfb => basis_set_b%pgf_radius
         set_radius_b => basis_set_b%set_radius
         scon_b => basis_set_b%scon
         zetb => basis_set_b%zet

         IF (use_cell_mapping) THEN
            ic = cell_to_index(cell(1), cell(2), cell(3))
            IF (ic < 1 .OR. ic > nimg) CYCLE
         ELSE
            ic = 1
         END IF

         IF (do_symmetric) THEN
            IF (iatom <= jatom) THEN
               irow = iatom
               icol = jatom
            ELSE
               irow = jatom
               icol = iatom
            END IF
            f0 = 2.0_dp
            ff = 2.0_dp
            IF (iatom == jatom) f0 = 1.0_dp
         ELSE
            irow = iatom
            icol = jatom
            f0 = 1.0_dp
            ff = 1.0_dp
         END IF
         DO i = 1, maxs
            NULLIFY (sint(i)%block)
            IF (dokp) THEN
               CALL dbcsr_get_block_p(matrix=matrixkp_s(i, ic)%matrix, &
                                      row=irow, col=icol, BLOCK=sint(i)%block, found=found)
               CPASSERT(found)
            ELSE
               CALL dbcsr_get_block_p(matrix=matrix_s(i)%matrix, &
                                      row=irow, col=icol, BLOCK=sint(i)%block, found=found)
               CPASSERT(found)
            END IF
         END DO
         IF (do_forces) THEN
            NULLIFY (p_block)
            IF (dokp) THEN
               CALL dbcsr_get_block_p(matrix=matrixkp_p(1, ic)%matrix, &
                                      row=irow, col=icol, block=p_block, found=found)
               CPASSERT(found)
            ELSE
               CALL dbcsr_get_block_p(matrix=matrix_p, row=irow, col=icol, &
                                      block=p_block, found=found)
               CPASSERT(found)
            END IF
         END IF
         trans = do_symmetric .AND. (iatom > jatom)

         rab2 = rab(1)*rab(1) + rab(2)*rab(2) + rab(3)*rab(3)
         dab = SQRT(rab2)

         DO iset = 1, nseta

            ncoa = npgfa(iset)*ncoset(la_max(iset))
            n1 = npgfa(iset)*(ncoset(la_max(iset)) - ncoset(la_min(iset) - 1))
            sgfa = first_sgfa(1, iset)

            DO jset = 1, nsetb

               IF (set_radius_a(iset) + set_radius_b(jset) < dab) CYCLE

!$             hash2 = MOD((iset - 1)*nsetb + jset, nlock) + 1
!$             hash = MOD(hash1 + hash2, nlock) + 1

               ncob = npgfb(jset)*ncoset(lb_max(jset))
               n2 = npgfb(jset)*(ncoset(lb_max(jset)) - ncoset(lb_min(jset) - 1))
               sgfb = first_sgfb(1, jset)

               ! calculate integrals and derivatives
               SELECT CASE (nder)
               CASE (0)
                  CALL overlap_ab(la_max(iset), la_min(iset), npgfa(iset), rpgfa(:, iset), zeta(:, iset), &
                                  lb_max(jset), lb_min(jset), npgfb(jset), rpgfb(:, jset), zetb(:, jset), &
                                  rab, sab=oint(:, :, 1))
               CASE (1)
                  CALL overlap_ab(la_max(iset), la_min(iset), npgfa(iset), rpgfa(:, iset), zeta(:, iset), &
                                  lb_max(jset), lb_min(jset), npgfb(jset), rpgfb(:, jset), zetb(:, jset), &
                                  rab, sab=oint(:, :, 1), dab=oint(:, :, 2:4))
               CASE (2)
                  CALL overlap_ab(la_max(iset), la_min(iset), npgfa(iset), rpgfa(:, iset), zeta(:, iset), &
                                  lb_max(jset), lb_min(jset), npgfb(jset), rpgfb(:, jset), zetb(:, jset), &
                                  rab, sab=oint(:, :, 1), dab=oint(:, :, 2:4), ddab=oint(:, :, 5:10))
               CASE DEFAULT
                  CPABORT("")
               END SELECT
               IF (do_forces .AND. ASSOCIATED(p_block) .AND. ((iatom /= jatom) .OR. use_virial)) THEN
                  ! Decontract P matrix block
                  owork = 0.0_dp
                  CALL block_add("OUT", owork, nsgfa(iset), nsgfb(jset), p_block, sgfa, sgfb, trans=trans)
                  CALL decontraction(owork, pmat, scon_a(:, sgfa:), n1, nsgfa(iset), scon_b(:, sgfb:), n2, &
                                     nsgfb(jset), trans=trans)
                  CALL force_trace(force_a, oint(:, :, 2:4), pmat, n1, n2, 3)
                  force_thread(:, iatom) = force_thread(:, iatom) - ff*force_a(:)
                  force_thread(:, jatom) = force_thread(:, jatom) + ff*force_a(:)
                  IF (use_virial) THEN
                     CALL virial_pair_force(pv_thread, -f0, force_a, rab)
                  END IF
               END IF
               ! Contraction
               DO i = 1, maxs
                  f = 1.0_dp
                  IF (ndod(i) == 1 .AND. trans) f = -1.0_dp
                  CALL contraction(oint(:, :, i), owork, ca=scon_a(:, sgfa:), na=n1, ma=nsgfa(iset), &
                                   cb=scon_b(:, sgfb:), nb=n2, mb=nsgfb(jset), fscale=f, trans=trans)
!$                CALL omp_set_lock(locks(hash))
                  CALL block_add("IN", owork, nsgfa(iset), nsgfb(jset), sint(i)%block, &
                                 sgfa, sgfb, trans=trans)
!$                CALL omp_unset_lock(locks(hash))
               END DO

            END DO
         END DO

      END DO
      IF (do_forces) DEALLOCATE (pmat)
      DEALLOCATE (oint, owork)
      DEALLOCATE (sint)
!$OMP DO
!$    DO lock_num = 1, nlock
!$       call omp_destroy_lock(locks(lock_num))
!$    END DO
!$OMP END DO

!$OMP SINGLE
!$    DEALLOCATE (locks)
!$OMP END SINGLE NOWAIT

!$OMP END PARALLEL

      IF (do_forces) THEN
         CALL get_atomic_kind_set(atomic_kind_set, atom_of_kind=atom_of_kind, kind_of=kind_of)
!$OMP DO
         DO iatom = 1, natom
            atom_a = atom_of_kind(iatom)
            ikind = kind_of(iatom)
            force(ikind)%overlap(:, atom_a) = force(ikind)%overlap(:, atom_a) + force_thread(:, iatom)
         END DO
!$OMP END DO
      END IF
      IF (do_forces .AND. use_virial) THEN
         virial%pv_overlap = virial%pv_overlap + pv_thread
         virial%pv_virial = virial%pv_virial + pv_thread
      END IF

      IF (dokp) THEN
         DO i = 1, maxs
            DO ic = 1, nimg
               CALL dbcsr_finalize(matrixkp_s(i, ic)%matrix)
               CALL dbcsr_filter(matrixkp_s(i, ic)%matrix, &
                                 dft_control%qs_control%eps_filter_matrix)
            END DO
         END DO
      ELSE
         DO i = 1, maxs
            CALL dbcsr_finalize(matrix_s(i)%matrix)
            CALL dbcsr_filter(matrix_s(i)%matrix, &
                              dft_control%qs_control%eps_filter_matrix)
         END DO
      END IF

      ! *** Release work storage ***
      DEALLOCATE (basis_set_list_a, basis_set_list_b)

      CALL timestop(handle)

   END SUBROUTINE build_overlap_matrix_low

! **************************************************************************************************
!> \brief   Calculation of the overlap matrix over Cartesian Gaussian functions.
!> \param   ks_env the QS env
!> \param   matrix_s The overlap matrix to be calculated
!> \param   basis_set_list_a basis set list to be used for bra in <a|b>
!> \param   basis_set_list_b basis set list to be used for ket in <a|b>
!> \param   sab_nl pair list (must be consistent with basis sets!)
!> \date    11.03.2016
!> \par     History
!>          Simplified version of build_overlap_matrix
!> \author  MK
!> \version 1.0
! **************************************************************************************************
   SUBROUTINE build_overlap_matrix_simple(ks_env, matrix_s, &
                                          basis_set_list_a, basis_set_list_b, sab_nl)

      TYPE(qs_ks_env_type), POINTER                      :: ks_env
      TYPE(dbcsr_p_type), DIMENSION(:), POINTER          :: matrix_s
      TYPE(gto_basis_set_p_type), DIMENSION(:), POINTER  :: basis_set_list_a, basis_set_list_b
      TYPE(neighbor_list_set_p_type), DIMENSION(:), &
         POINTER                                         :: sab_nl

      CHARACTER(len=*), PARAMETER :: routineN = 'build_overlap_matrix_simple'

      INTEGER                                            :: handle, iatom, icol, ikind, irow, iset, &
                                                            jatom, jkind, jset, ldsab, m1, m2, n1, &
                                                            n2, natom, ncoa, ncob, nkind, nseta, &
                                                            nsetb, sgfa, sgfb, slot
      INTEGER, DIMENSION(:), POINTER                     :: la_max, la_min, lb_max, lb_min, npgfa, &
                                                            npgfb, nsgfa, nsgfb
      INTEGER, DIMENSION(:, :), POINTER                  :: first_sgfa, first_sgfb
      LOGICAL                                            :: do_symmetric, found, trans
      REAL(KIND=dp)                                      :: dab, rab2
      REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :)        :: owork
      REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :)     :: oint
      REAL(KIND=dp), DIMENSION(3)                        :: rab
      REAL(KIND=dp), DIMENSION(:), POINTER               :: set_radius_a, set_radius_b
      REAL(KIND=dp), DIMENSION(:, :), POINTER            :: rpgfa, rpgfb, scon_a, scon_b, zeta, zetb
      TYPE(atomic_kind_type), DIMENSION(:), POINTER      :: atomic_kind_set
      TYPE(block_p_type), ALLOCATABLE, DIMENSION(:)      :: sint
      TYPE(dft_control_type), POINTER                    :: dft_control
      TYPE(gto_basis_set_type), POINTER                  :: basis_set_a, basis_set_b
      TYPE(qs_kind_type), DIMENSION(:), POINTER          :: qs_kind_set

!$    INTEGER(kind=omp_lock_kind), &
!$       ALLOCATABLE, DIMENSION(:) :: locks
!$    INTEGER                                            :: lock_num, hash, hash1, hash2
!$    INTEGER(KIND=int_8)                                :: iatom8
!$    INTEGER, PARAMETER                                 :: nlock = 501

      NULLIFY (dft_control)

      CALL timeset(routineN, handle)

      NULLIFY (atomic_kind_set)
      CALL get_ks_env(ks_env, &
                      atomic_kind_set=atomic_kind_set, &
                      natom=natom, &
                      qs_kind_set=qs_kind_set, &
                      dft_control=dft_control)

      ! check for symmetry
      CPASSERT(SIZE(sab_nl) > 0)
      CALL get_neighbor_list_set_p(neighbor_list_sets=sab_nl, symmetric=do_symmetric)

      nkind = SIZE(qs_kind_set)

      CALL dbcsr_allocate_matrix_set(matrix_s, 1)
      CALL create_sab_matrix(ks_env, matrix_s, "Matrix", basis_set_list_a, basis_set_list_b, &
                             sab_nl, do_symmetric)

      ldsab = 0
      DO ikind = 1, nkind
         basis_set_a => basis_set_list_a(ikind)%gto_basis_set
         CALL get_gto_basis_set(gto_basis_set=basis_set_a, maxco=m1, nsgf=m2)
         ldsab = MAX(m1, m2, ldsab)
         basis_set_b => basis_set_list_b(ikind)%gto_basis_set
         CALL get_gto_basis_set(gto_basis_set=basis_set_b, maxco=m1, nsgf=m2)
         ldsab = MAX(m1, m2, ldsab)
      END DO

!$OMP PARALLEL DEFAULT(NONE) &
!$OMP SHARED (ldsab,sab_nl,do_symmetric,ncoset,natom,&
!$OMP         matrix_s,basis_set_list_a,basis_set_list_b,locks)  &
!$OMP PRIVATE (oint,owork,sint,ikind,jkind,iatom,jatom,rab,basis_set_a,basis_set_b,&
!$OMP          first_sgfa, la_max, la_min, npgfa, nsgfa, nseta, rpgfa, set_radius_a, ncoa, ncob, &
!$OMP          zeta, first_sgfb, lb_max, lb_min, npgfb, nsetb, rpgfb, set_radius_b, nsgfb, dab, &
!$OMP          zetb, scon_a, scon_b, irow, icol, found, trans, rab2, n1, n2, sgfa, sgfb, iset, jset, &
!$OMP          slot, lock_num, hash, hash1, hash2, iatom8 )

!$OMP SINGLE
!$    ALLOCATE (locks(nlock))
!$OMP END SINGLE

!$OMP DO
!$    DO lock_num = 1, nlock
!$       call omp_init_lock(locks(lock_num))
!$    END DO
!$OMP END DO

      ALLOCATE (oint(ldsab, ldsab, 1), owork(ldsab, ldsab))
      ALLOCATE (sint(1))
      NULLIFY (sint(1)%block)

!$OMP DO SCHEDULE(GUIDED)
      DO slot = 1, sab_nl(1)%nl_size
         ikind = sab_nl(1)%nlist_task(slot)%ikind
         jkind = sab_nl(1)%nlist_task(slot)%jkind
         iatom = sab_nl(1)%nlist_task(slot)%iatom
         jatom = sab_nl(1)%nlist_task(slot)%jatom
         rab(1:3) = sab_nl(1)%nlist_task(slot)%r(1:3)
!$       iatom8 = (iatom - 1)*natom + jatom
!$       hash1 = INT(MOD(iatom8, INT(nlock, int_8)) + 1)

         basis_set_a => basis_set_list_a(ikind)%gto_basis_set
         IF (.NOT. ASSOCIATED(basis_set_a)) CYCLE
         basis_set_b => basis_set_list_b(jkind)%gto_basis_set
         IF (.NOT. ASSOCIATED(basis_set_b)) CYCLE
         ! basis ikind
         first_sgfa => basis_set_a%first_sgf
         la_max => basis_set_a%lmax
         la_min => basis_set_a%lmin
         npgfa => basis_set_a%npgf
         nseta = basis_set_a%nset
         nsgfa => basis_set_a%nsgf_set
         rpgfa => basis_set_a%pgf_radius
         set_radius_a => basis_set_a%set_radius
         scon_a => basis_set_a%scon
         zeta => basis_set_a%zet
         ! basis jkind
         first_sgfb => basis_set_b%first_sgf
         lb_max => basis_set_b%lmax
         lb_min => basis_set_b%lmin
         npgfb => basis_set_b%npgf
         nsetb = basis_set_b%nset
         nsgfb => basis_set_b%nsgf_set
         rpgfb => basis_set_b%pgf_radius
         set_radius_b => basis_set_b%set_radius
         scon_b => basis_set_b%scon
         zetb => basis_set_b%zet

         IF (do_symmetric) THEN
            IF (iatom <= jatom) THEN
               irow = iatom
               icol = jatom
            ELSE
               irow = jatom
               icol = iatom
            END IF
         ELSE
            irow = iatom
            icol = jatom
         END IF

         NULLIFY (sint(1)%block)
         CALL dbcsr_get_block_p(matrix=matrix_s(1)%matrix, &
                                row=irow, col=icol, BLOCK=sint(1)%block, found=found)
         CPASSERT(found)
         trans = do_symmetric .AND. (iatom > jatom)

         rab2 = rab(1)*rab(1) + rab(2)*rab(2) + rab(3)*rab(3)
         dab = SQRT(rab2)

         DO iset = 1, nseta

            ncoa = npgfa(iset)*ncoset(la_max(iset))
            n1 = npgfa(iset)*(ncoset(la_max(iset)) - ncoset(la_min(iset) - 1))
            sgfa = first_sgfa(1, iset)

            DO jset = 1, nsetb

               IF (set_radius_a(iset) + set_radius_b(jset) < dab) CYCLE

!$             hash2 = MOD((iset - 1)*nsetb + jset, nlock) + 1
!$             hash = MOD(hash1 + hash2, nlock) + 1

               ncob = npgfb(jset)*ncoset(lb_max(jset))
               n2 = npgfb(jset)*(ncoset(lb_max(jset)) - ncoset(lb_min(jset) - 1))
               sgfb = first_sgfb(1, jset)

               ! calculate integrals and derivatives
               CALL overlap_ab(la_max(iset), la_min(iset), npgfa(iset), rpgfa(:, iset), zeta(:, iset), &
                               lb_max(jset), lb_min(jset), npgfb(jset), rpgfb(:, jset), zetb(:, jset), &
                               rab, sab=oint(:, :, 1))
               ! Contraction
               CALL contraction(oint(:, :, 1), owork, ca=scon_a(:, sgfa:), na=n1, ma=nsgfa(iset), &
                                cb=scon_b(:, sgfb:), nb=n2, mb=nsgfb(jset), fscale=1.0_dp, trans=trans)
!$OMP CRITICAL(blockadd)
               CALL block_add("IN", owork, nsgfa(iset), nsgfb(jset), sint(1)%block, &
                              sgfa, sgfb, trans=trans)
!$OMP END CRITICAL(blockadd)

            END DO
         END DO

      END DO
      DEALLOCATE (oint, owork)
      DEALLOCATE (sint)
!$OMP DO
!$    DO lock_num = 1, nlock
!$       call omp_destroy_lock(locks(lock_num))
!$    END DO
!$OMP END DO

!$OMP SINGLE
!$    DEALLOCATE (locks)
!$OMP END SINGLE NOWAIT

!$OMP END PARALLEL

      CALL dbcsr_finalize(matrix_s(1)%matrix)
      CALL dbcsr_filter(matrix_s(1)%matrix, dft_control%qs_control%eps_filter_matrix)

      CALL timestop(handle)

   END SUBROUTINE build_overlap_matrix_simple

! **************************************************************************************************
!> \brief   Calculation of the force contribution from an overlap matrix
!>          over Cartesian Gaussian functions.
!> \param   ks_env the QS environment
!> \param   force holds the calcuated force Tr(P dS/dR)
!> \param   basis_type_a basis set to be used for bra in <a|b>
!> \param   basis_type_b basis set to be used for ket in <a|b>
!> \param   sab_nl pair list (must be consistent with basis sets!)
!> \param   matrix_p density matrix for force calculation
!> \param matrixkp_p ...
!> \date    11.03.2002
!> \par     History
!>          Enlarged functionality of this routine. Now overlap matrices based
!>          on different basis sets can be calculated, taking into account also
!>          mixed overlaps NOTE: the pointer to the overlap matrix must now be
!>          put into its corresponding env outside of this routine
!>          [Manuel Guidon]
!>          Generalized for derivatives and force calculations [JHU]
!>          This special version is only for forces [07.07.2014, JGH]
!> \author  MK/JGH
!> \version 1.0
! **************************************************************************************************
   SUBROUTINE build_overlap_force(ks_env, force, basis_type_a, basis_type_b, &
                                  sab_nl, matrix_p, matrixkp_p)

      TYPE(qs_ks_env_type), POINTER                      :: ks_env
      REAL(KIND=dp), DIMENSION(:, :), INTENT(INOUT)      :: force
      CHARACTER(LEN=*), INTENT(IN)                       :: basis_type_a, basis_type_b
      TYPE(neighbor_list_set_p_type), DIMENSION(:), &
         POINTER                                         :: sab_nl
      TYPE(dbcsr_type), OPTIONAL                         :: matrix_p
      TYPE(dbcsr_p_type), DIMENSION(:), OPTIONAL         :: matrixkp_p

      CHARACTER(len=*), PARAMETER :: routineN = 'build_overlap_force'

      INTEGER :: handle, iatom, ic, icol, ikind, irow, iset, jatom, jkind, jset, ldsab, n1, n2, &
         natom, ncoa, ncob, nder, nimg, nkind, nseta, nsetb, sgfa, sgfb, slot
      INTEGER, DIMENSION(3)                              :: cell
      INTEGER, DIMENSION(:), POINTER                     :: la_max, la_min, lb_max, lb_min, npgfa, &
                                                            npgfb, nsgfa, nsgfb
      INTEGER, DIMENSION(:, :), POINTER                  :: first_sgfa, first_sgfb
      INTEGER, DIMENSION(:, :, :), POINTER               :: cell_to_index
      LOGICAL                                            :: do_symmetric, dokp, found, trans, &
                                                            use_cell_mapping, use_virial
      REAL(KIND=dp)                                      :: dab, f0, ff, rab2
      REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :)        :: pab, sab
      REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :)     :: drab
      REAL(KIND=dp), DIMENSION(3)                        :: force_a, rab
      REAL(KIND=dp), DIMENSION(3, 3)                     :: virial_thread
      REAL(KIND=dp), DIMENSION(:), POINTER               :: set_radius_a, set_radius_b
      REAL(KIND=dp), DIMENSION(3, SIZE(force, 2))        :: force_thread
      REAL(KIND=dp), DIMENSION(:, :), POINTER            :: p_block, rpgfa, rpgfb, scon_a, scon_b, &
                                                            zeta, zetb
      TYPE(dft_control_type), POINTER                    :: dft_control
      TYPE(gto_basis_set_p_type), DIMENSION(:), POINTER  :: basis_set_list_a, basis_set_list_b
      TYPE(gto_basis_set_type), POINTER                  :: basis_set_a, basis_set_b
      TYPE(kpoint_type), POINTER                         :: kpoints
      TYPE(qs_kind_type), DIMENSION(:), POINTER          :: qs_kind_set
      TYPE(virial_type), POINTER                         :: virial

      CALL timeset(routineN, handle)

      NULLIFY (qs_kind_set)
      CALL get_ks_env(ks_env=ks_env, qs_kind_set=qs_kind_set, dft_control=dft_control)
      nimg = dft_control%nimages

      ! test for matrices (kpoints or standard gamma point)
      IF (PRESENT(matrix_p)) THEN
         dokp = .FALSE.
         use_cell_mapping = .FALSE.
      ELSEIF (PRESENT(matrixkp_p)) THEN
         dokp = .TRUE.
         CALL get_ks_env(ks_env=ks_env, kpoints=kpoints)
         CALL get_kpoint_info(kpoint=kpoints, cell_to_index=cell_to_index)
         use_cell_mapping = (SIZE(cell_to_index) > 1)
      ELSE
         CPABORT("")
      END IF

      nkind = SIZE(qs_kind_set)
      nder = 1

      ! check for symmetry
      CPASSERT(SIZE(sab_nl) > 0)
      CALL get_neighbor_list_set_p(neighbor_list_sets=sab_nl, symmetric=do_symmetric)

      CALL get_ks_env(ks_env=ks_env, virial=virial)
      use_virial = virial%pv_availability .AND. (.NOT. virial%pv_numer)
      virial_thread = 0.0_dp

      ! set up basis sets
      ALLOCATE (basis_set_list_a(nkind), basis_set_list_b(nkind))
      CALL basis_set_list_setup(basis_set_list_a, basis_type_a, qs_kind_set)
      CALL basis_set_list_setup(basis_set_list_b, basis_type_b, qs_kind_set)
      ldsab = get_memory_usage(qs_kind_set, basis_type_a, basis_type_b)

      natom = SIZE(force, 2)
      force_thread = 0.0_dp

!$OMP PARALLEL DEFAULT(NONE) &
!$OMP SHARED (ldsab, do_symmetric, ncoset, nder, use_virial, force, virial, ndod, sab_nl, cell_to_index, &
!$OMP         matrix_p, basis_set_list_a, basis_set_list_b, dokp, use_cell_mapping, nimg, matrixkp_p)  &
!$OMP PRIVATE (ikind, jkind, iatom, jatom, rab, ic, &
!$OMP          basis_set_a, basis_set_b, sab, pab, drab, &
!$OMP          first_sgfa, la_max, la_min, npgfa, nsgfa, nseta, rpgfa, set_radius_a, ncoa, ncob, force_a, &
!$OMP          zeta, first_sgfb, lb_max, lb_min, npgfb, nsetb, rpgfb, set_radius_b, nsgfb, p_block, dab, &
!$OMP          zetb, scon_a, scon_b, irow, icol, f0, ff, found, trans, rab2, n1, n2, sgfa, sgfb, iset, jset, &
!$OMP          slot, cell) &
!$OMP REDUCTION (+ : virial_thread, force_thread )

      ! *** Allocate work storage ***
      ALLOCATE (sab(ldsab, ldsab), pab(ldsab, ldsab))
      ALLOCATE (drab(ldsab, ldsab, 3))

      ! Loop over neighbor list
!$OMP DO SCHEDULE(GUIDED)
      DO slot = 1, sab_nl(1)%nl_size
         ikind = sab_nl(1)%nlist_task(slot)%ikind
         jkind = sab_nl(1)%nlist_task(slot)%jkind
         iatom = sab_nl(1)%nlist_task(slot)%iatom
         jatom = sab_nl(1)%nlist_task(slot)%jatom
         cell(:) = sab_nl(1)%nlist_task(slot)%cell(:)
         rab(1:3) = sab_nl(1)%nlist_task(slot)%r(1:3)

         basis_set_a => basis_set_list_a(ikind)%gto_basis_set
         IF (.NOT. ASSOCIATED(basis_set_a)) CYCLE
         basis_set_b => basis_set_list_b(jkind)%gto_basis_set
         IF (.NOT. ASSOCIATED(basis_set_b)) CYCLE
         ! basis ikind
         first_sgfa => basis_set_a%first_sgf
         la_max => basis_set_a%lmax
         la_min => basis_set_a%lmin
         npgfa => basis_set_a%npgf
         nseta = basis_set_a%nset
         nsgfa => basis_set_a%nsgf_set
         rpgfa => basis_set_a%pgf_radius
         set_radius_a => basis_set_a%set_radius
         scon_a => basis_set_a%scon
         zeta => basis_set_a%zet
         ! basis jkind
         first_sgfb => basis_set_b%first_sgf
         lb_max => basis_set_b%lmax
         lb_min => basis_set_b%lmin
         npgfb => basis_set_b%npgf
         nsetb = basis_set_b%nset
         nsgfb => basis_set_b%nsgf_set
         rpgfb => basis_set_b%pgf_radius
         set_radius_b => basis_set_b%set_radius
         scon_b => basis_set_b%scon
         zetb => basis_set_b%zet

         IF (use_cell_mapping) THEN
            ic = cell_to_index(cell(1), cell(2), cell(3))
            IF (ic < 1 .OR. ic > nimg) CYCLE
         ELSE
            ic = 1
         END IF

         IF (do_symmetric) THEN
            IF (iatom <= jatom) THEN
               irow = iatom
               icol = jatom
            ELSE
               irow = jatom
               icol = iatom
            END IF
            f0 = 2.0_dp
            IF (iatom == jatom) f0 = 1.0_dp
            ff = 2.0_dp
         ELSE
            irow = iatom
            icol = jatom
            f0 = 1.0_dp
            ff = 1.0_dp
         END IF
         NULLIFY (p_block)
         IF (dokp) THEN
            CALL dbcsr_get_block_p(matrix=matrixkp_p(ic)%matrix, row=irow, col=icol, &
                                   block=p_block, found=found)
         ELSE
            CALL dbcsr_get_block_p(matrix=matrix_p, row=irow, col=icol, &
                                   block=p_block, found=found)
         END IF

         trans = do_symmetric .AND. (iatom > jatom)

         rab2 = rab(1)*rab(1) + rab(2)*rab(2) + rab(3)*rab(3)
         dab = SQRT(rab2)

         DO iset = 1, nseta

            ncoa = npgfa(iset)*ncoset(la_max(iset))
            n1 = npgfa(iset)*(ncoset(la_max(iset)) - ncoset(la_min(iset) - 1))
            sgfa = first_sgfa(1, iset)

            DO jset = 1, nsetb

               IF (set_radius_a(iset) + set_radius_b(jset) < dab) CYCLE

               ncob = npgfb(jset)*ncoset(lb_max(jset))
               n2 = npgfb(jset)*(ncoset(lb_max(jset)) - ncoset(lb_min(jset) - 1))
               sgfb = first_sgfb(1, jset)

               IF (ASSOCIATED(p_block) .AND. ((iatom /= jatom) .OR. use_virial)) THEN
                  ! Decontract P matrix block
                  sab = 0.0_dp
                  CALL block_add("OUT", sab, nsgfa(iset), nsgfb(jset), p_block, sgfa, sgfb, trans=trans)
                  CALL decontraction(sab, pab, scon_a(:, sgfa:), n1, nsgfa(iset), scon_b(:, sgfb:), n2, &
                                     nsgfb(jset), trans=trans)
                  ! calculate integrals and derivatives
                  CALL overlap_ab(la_max(iset), la_min(iset), npgfa(iset), rpgfa(:, iset), zeta(:, iset), &
                                  lb_max(jset), lb_min(jset), npgfb(jset), rpgfb(:, jset), zetb(:, jset), &
                                  rab, dab=drab)
                  CALL force_trace(force_a, drab, pab, n1, n2, 3)
                  force_thread(1:3, iatom) = force_thread(1:3, iatom) - ff*force_a(1:3)
                  force_thread(1:3, jatom) = force_thread(1:3, jatom) + ff*force_a(1:3)
                  IF (use_virial) THEN
                     CALL virial_pair_force(virial_thread, -f0, force_a, rab)
                  END IF
               END IF

            END DO
         END DO

      END DO
      DEALLOCATE (sab, pab, drab)
!$OMP END PARALLEL

!$OMP PARALLEL DEFAULT(NONE) &
!$OMP SHARED(force,force_thread,natom)
!$OMP WORKSHARE
      force(1:3, 1:natom) = force(1:3, 1:natom) + force_thread(1:3, 1:natom)
!$OMP END WORKSHARE
!$OMP END PARALLEL
      IF (use_virial) THEN
         virial%pv_virial = virial%pv_virial + virial_thread
         virial%pv_overlap = virial%pv_overlap + virial_thread
      END IF

      DEALLOCATE (basis_set_list_a, basis_set_list_b)

      CALL timestop(handle)

   END SUBROUTINE build_overlap_force

! **************************************************************************************************
!> \brief Setup the structure of a sparse matrix based on the overlap
!>        neighbor list
!> \param ks_env         The QS environment
!> \param matrix_s       Matrices to be constructed
!> \param matrix_name    Matrix base name
!> \param basis_set_list_a Basis set used for <a|
!> \param basis_set_list_b Basis set used for |b>
!> \param sab_nl         Overlap neighbor list
!> \param symmetric      Is symmetry used in the neighbor list?
! **************************************************************************************************
   SUBROUTINE create_sab_matrix_1d(ks_env, matrix_s, matrix_name, &
                                   basis_set_list_a, basis_set_list_b, sab_nl, symmetric)

      TYPE(qs_ks_env_type), POINTER                      :: ks_env
      TYPE(dbcsr_p_type), DIMENSION(:), POINTER          :: matrix_s
      CHARACTER(LEN=*), INTENT(IN), OPTIONAL             :: matrix_name
      TYPE(gto_basis_set_p_type), DIMENSION(:), POINTER  :: basis_set_list_a, basis_set_list_b
      TYPE(neighbor_list_set_p_type), DIMENSION(:), &
         POINTER                                         :: sab_nl
      LOGICAL, INTENT(IN)                                :: symmetric

      CHARACTER(LEN=12)                                  :: cgfsym
      CHARACTER(LEN=32)                                  :: symmetry_string
      CHARACTER(LEN=default_string_length)               :: mname, name
      INTEGER                                            :: i, maxs, natom
      INTEGER, DIMENSION(:), POINTER                     :: col_blk_sizes, row_blk_sizes
      TYPE(dbcsr_distribution_type), POINTER             :: dbcsr_dist
      TYPE(particle_type), DIMENSION(:), POINTER         :: particle_set
      TYPE(qs_kind_type), DIMENSION(:), POINTER          :: qs_kind_set

      CALL get_ks_env(ks_env=ks_env, particle_set=particle_set, &
                      qs_kind_set=qs_kind_set, dbcsr_dist=dbcsr_dist)

      natom = SIZE(particle_set)

      IF (PRESENT(matrix_name)) THEN
         mname = matrix_name
      ELSE
         mname = "DUMMY"
      END IF

      maxs = SIZE(matrix_s)

      ALLOCATE (row_blk_sizes(natom), col_blk_sizes(natom))

      CALL get_particle_set(particle_set, qs_kind_set, nsgf=row_blk_sizes, &
                            basis=basis_set_list_a)
      CALL get_particle_set(particle_set, qs_kind_set, nsgf=col_blk_sizes, &
                            basis=basis_set_list_b)

      ! prepare for allocation
      IF (symmetric) THEN
         symmetry_string = dbcsr_type_symmetric
      ELSE
         symmetry_string = dbcsr_type_no_symmetry
      END IF

      DO i = 1, maxs
         IF (symmetric) THEN
            IF (ndod(i) == 1) THEN
               ! odd derivatives are anti-symmetric
               symmetry_string = dbcsr_type_antisymmetric
            ELSE
               symmetry_string = dbcsr_type_symmetric
            END IF
         ELSE
            symmetry_string = dbcsr_type_no_symmetry
         END IF
         cgfsym = cgf_symbol(1, indco(1:3, i))
         IF (i == 1) THEN
            name = mname
         ELSE
            name = TRIM(cgfsym(4:))//" DERIVATIVE OF THE "//TRIM(mname)// &
                   " W.R.T. THE NUCLEAR COORDINATES"
         END IF
         CALL compress(name)
         CALL uppercase(name)
         ALLOCATE (matrix_s(i)%matrix)
         CALL dbcsr_create(matrix=matrix_s(i)%matrix, &
                           name=TRIM(name), &
                           dist=dbcsr_dist, matrix_type=symmetry_string, &
                           row_blk_size=row_blk_sizes, col_blk_size=col_blk_sizes)
         CALL cp_dbcsr_alloc_block_from_nbl(matrix_s(i)%matrix, sab_nl)
      END DO

      DEALLOCATE (row_blk_sizes, col_blk_sizes)

   END SUBROUTINE create_sab_matrix_1d

! **************************************************************************************************
!> \brief Setup the structure of a sparse matrix based on the overlap
!>        neighbor list, 2d version
!> \param ks_env         The QS environment
!> \param matrix_s       Matrices to be constructed
!> \param matrix_name    Matrix base name
!> \param basis_set_list_a Basis set used for <a|
!> \param basis_set_list_b Basis set used for |b>
!> \param sab_nl         Overlap neighbor list
!> \param symmetric      Is symmetry used in the neighbor list?
! **************************************************************************************************
   SUBROUTINE create_sab_matrix_2d(ks_env, matrix_s, matrix_name, &
                                   basis_set_list_a, basis_set_list_b, sab_nl, symmetric)

      TYPE(qs_ks_env_type), POINTER                      :: ks_env
      TYPE(dbcsr_p_type), DIMENSION(:, :), POINTER       :: matrix_s
      CHARACTER(LEN=*), INTENT(IN), OPTIONAL             :: matrix_name
      TYPE(gto_basis_set_p_type), DIMENSION(:), POINTER  :: basis_set_list_a, basis_set_list_b
      TYPE(neighbor_list_set_p_type), DIMENSION(:), &
         POINTER                                         :: sab_nl
      LOGICAL, INTENT(IN)                                :: symmetric

      CHARACTER(LEN=12)                                  :: cgfsym
      CHARACTER(LEN=32)                                  :: symmetry_string
      CHARACTER(LEN=default_string_length)               :: mname, name
      INTEGER                                            :: i1, i2, natom
      INTEGER, DIMENSION(:), POINTER                     :: col_blk_sizes, row_blk_sizes
      TYPE(dbcsr_distribution_type), POINTER             :: dbcsr_dist
      TYPE(particle_type), DIMENSION(:), POINTER         :: particle_set
      TYPE(qs_kind_type), DIMENSION(:), POINTER          :: qs_kind_set

      CALL get_ks_env(ks_env=ks_env, particle_set=particle_set, &
                      qs_kind_set=qs_kind_set, dbcsr_dist=dbcsr_dist)

      natom = SIZE(particle_set)

      IF (PRESENT(matrix_name)) THEN
         mname = matrix_name
      ELSE
         mname = "DUMMY"
      END IF

      ALLOCATE (row_blk_sizes(natom), col_blk_sizes(natom))

      CALL get_particle_set(particle_set, qs_kind_set, nsgf=row_blk_sizes, &
                            basis=basis_set_list_a)
      CALL get_particle_set(particle_set, qs_kind_set, nsgf=col_blk_sizes, &
                            basis=basis_set_list_b)

      ! prepare for allocation
      IF (symmetric) THEN
         symmetry_string = dbcsr_type_symmetric
      ELSE
         symmetry_string = dbcsr_type_no_symmetry
      END IF

      DO i2 = 1, SIZE(matrix_s, 2)
         DO i1 = 1, SIZE(matrix_s, 1)
            IF (symmetric) THEN
               IF (ndod(i1) == 1) THEN
                  ! odd derivatives are anti-symmetric
                  symmetry_string = dbcsr_type_antisymmetric
               ELSE
                  symmetry_string = dbcsr_type_symmetric
               END IF
            ELSE
               symmetry_string = dbcsr_type_no_symmetry
            END IF
            cgfsym = cgf_symbol(1, indco(1:3, i1))
            IF (i1 == 1) THEN
               name = mname
            ELSE
               name = TRIM(cgfsym(4:))//" DERIVATIVE OF THE "//TRIM(mname)// &
                      " W.R.T. THE NUCLEAR COORDINATES"
            END IF
            CALL compress(name)
            CALL uppercase(name)
            ALLOCATE (matrix_s(i1, i2)%matrix)
            CALL dbcsr_create(matrix=matrix_s(i1, i2)%matrix, &
                              name=TRIM(name), &
                              dist=dbcsr_dist, matrix_type=symmetry_string, &
                              row_blk_size=row_blk_sizes, col_blk_size=col_blk_sizes)
            CALL cp_dbcsr_alloc_block_from_nbl(matrix_s(i1, i2)%matrix, sab_nl)
         END DO
      END DO

      DEALLOCATE (row_blk_sizes, col_blk_sizes)

   END SUBROUTINE create_sab_matrix_2d

END MODULE qs_overlap
